;;   This file is part of scheme-GNUnet, a partial Scheme port of GNUnet.
;;   Copyright (C) 2003, 2004, 2006, 2009, 2020 GNUnet e.V.
;;
;;   GNUnet is free software: you can redistribute it and/or modify it
;;   under the terms of the GNU Affero General Public License as published
;;   by the Free Software Foundation, either version 3 of the License,
;;   or (at your option) any later version.
;;
;;   GNUnet is distributed in the hope that it will be useful, but
;;   WITHOUT ANY WARRANTY; without even the implied warranty of
;;   MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the GNU
;;   Affero General Public License for more details.
;;
;;   You should have received a copy of the GNU Affero General Public License
;;   along with this program.  If not, see <http://www.gnu.org/licenses/>.
;;
;;   SPDX-License-Identifier: AGPL-3.0-or-later
;;
;;   As a special exception to the GNU Affero General Public License,
;;   the file may be relicensed under any license used for
;;   most source code of GNUnet 0.13.1, or later versions, as published by
;;   GNUnet e.V.

;; This Scheme module allows for the construction of GNUnet directories.
;; Note that this isn't a binding to libgnunet_fs, but rather a Scheme
;; port of relevant bits.  This is done this way because this module is
;; intended for use by Guix (for substitutes and/or distributing sources
;; over GNUnet), where directories may be formed independently by separate
;; systems, but should ideally only have a single representation in
;; the GNUnet FS.

;; Q: why not simply push tarballs/narballs into GNUnet FS?
;; A: deduplication

;; Limitations:
;;   * Only CHK URI's are supported. This doesn't seem a likely issue,
;;     as LOC URI's aren't generated by default (I think) and aren't
;;     reproducible anyway.

;; Changes from upstream GNUnet:
;;  * Pure API
;;  * Linked lists are replaced with vectors
;;  * BuilderEntry doesn't contain serialised meta-data,
;;    instead it contains the non-serialised meta-data.
;;  * URI's are represented by strings (note: GNUnet FS URI's are
;;    always ASCII).

(library (gnu gnunet directory)
  (export meta-data-mark-directory
	  make-directory-entry directory-entry?
	  directory-entry-uri directory-entry-meta
	  build-directory)
  (import (rnrs base)
	  (rnrs control)
          (rnrs records syntactic)
	  (rnrs bytevectors)
	  (only (guile) floor/ 1+)
	  (ice-9 receive)
          (only (gnu gnunet fs-uri) chk-uri-file-length chk-uri-parse)
          (only (srfi srfi-43) vector-unfold)
	  (only (gnu gnunet metadata) meta-data-extend)
	  (prefix (only (gnu extractor metatypes)
			MIMETYPE GNUNET_FULL_DATA)
		  EXTRACTOR_METATYPE_)
	  (prefix (only (gnu extractor metaformats)
			METAFORMAT_UTF8
			METAFORMAT_BINARY)
		  EXTRACTOR_))

  ;; constant from gnunet-0.13.1/src/fs/fs.h
  (define DBLOCK_SIZE (* 32 1024))
  ;; constant from gnunet-0.13.1/src/fs/fs_api.h
  (define MAX_INLINE_SIZE 65536)

  ;; String that is used to indicate that a file
  ;; is a GNUnet directory.
  (define directory-magic #u8(#x89 #x47 #x4e #x44 #x0d #x0a #x1a #x0a))

  ;; mime type for gnunet directories
  (define directory-mime "application/gnunet-directory")

  ;; Corresponds to BuilderEntry, without the linked list
  (define-record-type (<directory-entry> %make-directory-entry
					 directory-entry?)
    (fields (immutable uri directory-entry-uri)
	    ;; possibly contains inlined data
	    (immutable meta directory-entry-meta)))
  ;; DirectoryBuilder corresponds to a vector of <directory-entry>

  (define (meta-data-mark-directory md)
    "Set the MIMETYPE information for the given
metadata to \"application/gnunet-directory\"

The MIMETYPE may not be already set.

@param md metadata to add mimetype to"
    ;; TODO: check for pre-existing mime-types
    (meta-data-extend md
		      "<gnunet>"
		      EXTRACTOR_METATYPE_MIMETYPE
		      EXTRACTOR_METAFORMAT_UTF8
		      "text/plain"
		      (string->utf8 directory-mime)))

  (define (make-directory-entry uri meta-old data)
    "Create a directory entry, possibly inlined.

@param uri uri of the entry (a string, must not be a KSK)
@param meta-old metadata of the entry, before inlining
@param data raw data of the entry, can be #f, otherwise
       data must point to exactly the number of bytes specified
       by the uri which must be of type CHK

For reproducibility, it is important to be consistent in the
use or inuse of data."
    (let ((fsize (chk-uri-file-length (chk-uri-parse uri)))
	  (meta-old-size (meta-serialized-size meta-old)))
      (receive (meta-to-use meta-size)
	  ;; Try inlining data, except if it's too large.
          (if (and data
		   (< fsize MAX-INLINE-SIZE)
		   (< 0 fsize)) ; data not too large?
              (let* ((meta
		      (meta-data-extend meta-old
					"<gnunet>"
					EXTRACTOR_METATYPE_GNUNET_FULL_DATA
					EXTRACTOR_METAFORMAT_BINARY
					#f
					data))
		     (slen (+ (string-length uri) 1))
                     (mdxs (meta-serialized-size meta)))
		(if (= (floor/ (+ slen 4 mdxs -1) DBLOCK_SIZE)
		       (floor/ (+ slen 4 meta-old-size  -1) DBLOCK_SIZE))
		    ;; adding full data would not cause us to cross
		    ;; additional blocks, so add it!
		    (values meta mdxs)
		    ;; too large
		    (values meta-old meta-old-size)))
	      (values meta-old meta-old-size))
	;; compute entry
	(%make-directory-entry uri meta-to-use))))

  (define (block-align! start count sizes perm)
    "Compute a permuation of the blocks to
minimize the cost of alignment.  Greedy packer.

@param start starting position for the first block
@param count size of the two arrays
@param sizes the sizes of the individual blocks
@param perm  the permutation of the blocks (updated)"
    (do ((i 0 (1+ i))
	 (cpos start (do-align start (+ (vector-ref sizes i) cpos))))
        ((>= i count))
      (let loop ((j 1) (best #f) (badness #x7FFFFFFF))
        (if (< j count)
	    (let* ((cval (vector-ref perm j))
		   (cend (+ cpos (vector-ref sizes cval)))
		   (cbad (cond ((= (mod cpos DBLOCK_SIZE) 0)
				(- (mod cend DBLOCK_SIZE)))
			       ((= (floor/ cpos DBLOCK_SIZE)
				   (floor/ cend DBLOCK_SIZE))
				;; Data fits into the same block!
				;; Prefer small left-overs!
				(- DBLOCK_SIZE (mod cend DBLOCK_SIZE)))
			       (else
				;; Would have to waste space to re-align,
				;; add big factor, this case is a real loss
				;; (proportional to space wasted)!
				(* DBLOCK_SIZE (- DBLOCK_SIZE
						  (mod cpos DBLOCK_SIZE)))))))
	      (if (< cbad badness)
		  (loop (1+ j) j cbad)
		  (loop (1+ j) best badness))))
	(let ((old-perm (vector-ref perm i)))
	  (vector-set! perm i (vector-ref perm best))
	  (vector-set! perm best old-perm)))))

  (define (do-align start end)
    "Given the start and end position of a block of
data, return the end position of that data
after alignment to the DBLOCK_SIZE."
    (let ((align (- end (mod end DBLOCK_SIZE))))
      (if (and (< start align) (> end align))
	  (+ align end (- start))
	  end)))

  (define (directory-size-etc meta dir-vector)
    "Compute the size of the encoded directory,
passed as a vector, and some other things.
The directory itself must have some sensible meta-data defined."
    (let* ((header-size (+ (bytevector-length directory-magic) 4))
	   (with-meta-size (+ header-size (meta-serialized-size meta))))
      (if (< 0 (vector-length dir-vector))
          (let ((sizes (vector-map entry-length dir-vector))
		(perm  (vector-unfold values (vector-length dir-vector))))
	    (block-align! with-meta-size (vector-length dir-vector) sizes perm)
	    ;; compute final size with alignment
	    (let loop ((i 0)
		       (size with-meta-size)
		       (psize with-meta-size))
	      (if (< i (vector-length dir-vector))
		  (loop (1+ i)
			(do-align (+ size (vector-length sizes)) size)
			size)
		  (values size sizes perm))))
	  (values with-meta-size #f #f))))

  (define (build-directory meta dir-vector)
    "Finish building the directory. 
Returns the directory in-memory as a bytevector.

@param dir-vector directory entries of directory
@param meta metadata of directory (see meta-data-mark-directory)
@return the directory as a bytevector"
    (receive (size sizes perm)
	(directory-size-etc meta dir-vector)
      (let* ((bv (make-bytevector size 0))
	     (offset0 (bytevector-length directory-magic))
	     (meta-serialize-ret ; TODO: is this a size?
	      (meta-data-serialize-full! meta bv offset0 (- size offset0 4))))
        (bytevector-copy! directory-magic 0 bv 0
			  (bytevector-length directory-magic))
	(bytevector-u32-set! bv offset0 meta-serialize-ret (endianness big))
	(let loop ((j 0) (offset (+ offset0 4 meta-serialize-ret)))
	  (if (< j (vector-length dir-vector))
	      (let* ((i (vector-ref perm j))
		     (psize offset)
		     (offset (do-align psize (+ offset (vector-ref sizes i)))))
		(bytevector-copy!
		 (directory-entry-bv (vector-ref dir-vector i)) 0
		 bv (- offset (vector-ref sizes i)) (vector-ref sizes i))
		(loop (1+ j) offset))
	      (begin (assert (= offset size))
		     bv)))))))
